The PC-SIG Library 9/The PC-SIG Library on CD ROM - Ninth Edition.iso/201_300/DISK0214/DISK0214.ZIP/SCAN.BAS

BASIC Source File | 1983-03-10 | 31KB | 1,023 lines

3 DEFDBL X
4 DEFINT A-W,Y-Z
5 DIM F$(15),FLDN$(15,30),FTY(15,30),FL(15,30)
10 DIM X$(30),Y$(30)
13 DIM L(15),NREC(15),Z$(30),EGL(30),KT(30),I#(30,10),I$(30,10),ORN(30)
14 DIM X(30),CK$(30),SN$(30),SFN(30)
16 DIM KY(15,30),KEYLIST(15,30),L$(10,100),LEND(30),CL(30)
17 DIM ORNFLG(30),FTA(30),ATF(30),BTF(30),IMAX(30)
18 DIM SU%(40),S!(30),SUM#(40)
20 DIM XL(40)
22 DIM ORFLG(30),D(30),TFN(30),KTSUM(30),SUMFN(30)
25 DIM S#(30)
26 DIM MAX(10),Z%(30),SU#(30),D#(30),EFN(10,30)
35 DIM K$(80)
42 DIM MAXK(30),SUMRN(5,5),SUMFLDN(10,5),MAXSAF(9)
60 DIM SAF#(3,200)
61 CH = 29: PRINT FRE(0)
70 NE = 0
75 GOSUB 50000
80 GOSUB 10000
90 GOSUB 11000
400 GOSUB 13000
402 IF KD < 5 THEN GOSUB 11000
404 GOSUB 13000
410 PRINT "******  SELECTIVE SCAN PROGRAM   --  WHAT FILE DO YOU WANT:  *****"
420 PRINT ""
425 PRINT " 0  - *** EXIT PROGRAM ***"
430 FOR I = 1 TO MAXF
440 PRINT I;" - ";F$(I)
450 NEXT I
460 PRINT ""
470 PRINT "***** ENTER THE NUMBER OF THE FILE YOU WANT THEN PRESS RETURN *****"
475 GOSUB 14000
477 IF DT# < 0 OR DT#>MAXF  GOTO 475
480 A = DT#
482 IF A = 0 GOTO 51000
483 GOSUB 13000
484 PRINT "FILE : "; F$(A)
485 GOSUB 2300
490 GOSUB 2500
500 GOTO 6000
2300 REM **************  DISK  SELECTION  ***************
2302 IF HDISK = 2 THEN GOSUB 13000
2303 IF HDISK = 2 THEN GOTO 2360
2304 PRINT ""
2305 PRINT "************  WHICH DISK DRIVE IS THE FILE ON  **************"
2310 PRINT ""
2315 PRINT "                 1 - DISK DRIVE A"
2320 PRINT "                 2 - DISK DRIVE B"
2325 PRINT "                 3 - DISK DRIVE C"
2330 PRINT "                 4 - DISK DRIVE D"
2335 PRINT ""
2340 PRINT "***********  ENTER THE NUMBER THEN PRESS RETURN  ************"
2345 GOSUB 14000
2347 IF DT# < 0 OR DT#>4 GOTO 2345
2350 T = DT#
2355 ON T GOTO 2360,2370,2380,2390
2360 T$ = F$(A)
2365 GOTO 2490
2370 T$ = "B:"+F$(A)
2375 GOTO 2490
2380 T$ = "C:"+F$(A)
2385 GOTO 2490
2390 T$ = "D:"+F$(A)
2490 RETURN
2500 REM *******  OPEN FILE SUBROUTINE  *******
2503 CLOSE #1
2505 OPEN "R",#1,T$,L(A)
2507 D = 0
2510 FOR T = 1 TO NREC(A)
2520 FIELD #1,D AS DY$,FL(A,T) AS X$(T)
2530 D = D + FL(A,T)
2540 NEXT T
2543 GOSUB 7800
2545 RETURN
2550 REM *******   OPEN SECOND FILE  *******
2553 CLOSE #2
2555 OPEN "R",#2,T$,L(B)
2557 D = 0
2560 FOR T = 1 TO NREC(B)
2565 FIELD #2,D AS DY$,FL(B,T) AS Y$(T)
2570 D = D + FL(B,T)
2575 NEXT T
2578 RETURN
2580 REM *******   OPEN THIRD FILE  *******
2582 PRINT C,F$(C),L(C)
2584 OPEN "R",#2,F$(C),L(C)
2586 D = 0
2588 FOR T = 1 TO NREC(C)
2590 FIELD #2,D AS DY$,FL(C,T) AS Z$(T)
2592 D = D + FL(C,T)
2594 NEXT T
2596 RETURN
3010 GOTO 400
6000  REM  **********  LOOP THROUGH FIELDS  ************
6001 EFLG = 0:GOSUB 10700
6002 GOSUB 10200
6003 FOR Q = 1 TO NREC(A)
6006 GOSUB 6045
6009 NEXT Q
6010 REM *********  ADD OPTIONS  *******
6011 GOSUB 6603
6012 REM  **********  GET STARTING RECORD  **********
6015 GOSUB 6375
6018 REM  **********  GET RECORDS  ***********
6021 RN = RN - 1
6024 RN = RN + 1
6027 GOSUB 6090
6029 IF MATCH = 0 THEN PRINT "RECORD NUMBER ";RN ;" CONDITIONS NOT MET"
6030 IF MATCH = 0 GOTO 6024
6033 IF ADOPT > 1 THEN GOSUB 6759
6036 REM ********  PRINT ON PAPER  ********
6039 IF PRTOPT <> 1 THEN GOSUB 12000
6040 IF PRTOPT = 1 THEN GOSUB 12200
6042 GOTO 6024
6045 REM  ***********  LOOP THROUGH FIELDS  ************
6048 GOSUB 6129
6050 IF EGL(Q) = 1 THEN RETURN
6051 IF FTY(A,Q) = 1 THEN GOTO 6069
6057 REM ******  NUMBERS  ********
6060 ON EGL(Q) GOSUB 6045,6201,6234,6234,6201
6063 GOTO 6075
6066 REM ******  STRINGS  *******
6069 ON EGL(Q) GOSUB 6366,6246,6279,6279,6246
6072 REM **********  OR ROUTINE  ******
6075 GOSUB 6288
6078 IF DT# = 2 THEN GOSUB 6324
6087 RETURN
6090  REM  **************  GET RECORDS  *****************
6093  GOSUB 6396
6096 FOR Q = 1 TO NREC(A)
6099 REM ***********  CONVERT STRINGS TO DECIMALS  *********
6102 GOSUB 6435
6105 IF TEST = 1 THEN GOTO 6123
6108 IF TEST = 0 THEN GOSUB 6561
6111 REM *******  OR CHECK RESULTS  *********
6114 IF TEST = 1 THEN GOTO 6123
6117 MATCH = 0
6120 RETURN
6123 NEXT Q
6124 MATCH = 1
6126 RETURN
6129 GOSUB 13000
6138 PRINT "FIELD NUMBER: ";Q;"FIELD NAME: ";FLDN$(A,Q)
6141 K = 0
6147 PRINT "******************  CHOSE A RELATIONSHIP  *******************"
6153 PRINT " 0 - RETURN TO FILE OPTIONS  "
6156 PRINT " 1 - ANY VALUE IS ACCEPTABLE"
6159 PRINT " 2 - ";FLDN$(A,Q);" EQUAL TO  X"
6162 PRINT " 3 - ";FLDN$(A,Q);" GREATER THEN  X"
6165 PRINT " 4 - ";FLDN$(A,Q);" LESS THEN  X"
6166 PRINT " 5 - ";FLDN$(A,Q);" BETWEEN X AND Y"
6171 PRINT "***********  ENTER THE NUMBER THEN PRESS RETURN   ***********"
6177 REM ******* EGL MEANS EQUAL GREATER OR LESS THEN *****
6180 GOSUB 14000
6181 IF DT# < 0 OR DT#>5 GOTO 6180
6183 EGL(Q) = DT#
6189 IF EGL(Q) = 0 GOTO 3010
6192 RETURN
6195 IF FTY(A,Q)=1 THEN GOTO 6243
6198 ON EGL(Q) GOTO 6366,6201,6234,6234,6201
6201 PRINT "**********  ENTER THE VALUE OF X THEN PRESS RETURN  **********"
6204 K = K + 1
6207 KT(Q)=K
6209 GOSUB 14300
6210 I#(Q,K) = DT#
6211 IF EGL(Q) = 5 AND K = 2 THEN RETURN
6212 IF EGL(Q) = 5 THEN PRINT "**********  ENTER THE VALUE OF Y THEN PRESS RETURN  **********"
6213 IF EGL(Q) = 5 GOTO 6204
6215 PRINT "***************  MUTIPLE VALUES OF X ?  *****************"
6216 PRINT " 1 - MORE VALUES OF X "
6219 PRINT " 2 - NO MORE VALUES OF X "
6222 PRINT "*********  ENTER THE NUMBER THEN PRESS RETURN  **********"
6225 GOSUB 14000
6226 IF DT# <1 OR DT# > 2  GOTO 6225
6228 IF DT# = 1 GOTO 6201
6231 RETURN
6234 PRINT "*******  ENTER THE VALUE OF X THEN PRESS RETURN  ********"
6235 GOSUB 14300
6237 I#(Q,1) = DT#
6240 RETURN
6243 ON EGL(Q) GOTO 6366,6246,6279,6279
6246 PRINT "*******  ENTER THE VALUE OF X THEN PRESS RETURN  *******"
6249 K = K + 1
6252 KT(Q)=K
6253 MAX = 30
6254 GOSUB 15030
6255 I$(Q,K) = A$
6256 IF EGL(Q) = 5 AND K = 2 THEN RETURN
6257 IF EGL(Q) = 5 THEN PRINT "*******  ENTER THE VALUE OF Y THEN PRESS RETURN  *******"
6258 IF EGL(Q) = 5 THEN GOTO 6249
6260 PRINT "***************  MUTIPLE VALUES OF X ?  *****************"
6261 PRINT " 1 - MORE VALUES OF X "
6264 PRINT " 2 - NO MORE VALUES OF X "
6267 PRINT "*********  ENTER THE NUMBER THEN PRESS RETURN  **********"
6270 GOSUB 14000
6271 IF DT# <1 OR DT# >2  GOTO 6270
6273 IF DT# = 1  GOTO 6246
6276 RETURN
6279 PRINT "*******  ENTER THE VALUE OF X THEN PRESS RETURN  *******"
6280 MAX = 30
6281 GOSUB 15030
6282 I$(Q,1) = A$
6285 RETURN
6288 REM ************** OR / AND ROUTINE **************
6290 IF Q = NREC(A) THEN RETURN
6291 PRINT ""
6294 PRINT "*****  DO YOU WANT THIS CONDITON ORed WITH ANOTHER CONDITION  ****"
6297 PRINT "  1 -  NO, THIS CONDITION MUST BE MEET   "
6300 PRINT "  2 -  YES, CHECK ANOTHER FIELD TO SEE IF IT MEETS IT'S CONDITION"
6303 PRINT "     - Use only on the lower number field of the 2 you want to or"
6306 PRINT "*************  ENTER THE NUMBER THEN PRESS RETURN  ***************"
6309 GOSUB 14000
6310 IF DT# <1 OR DT# >2  GOTO 6309
6315 ORN(Q) = 0
6318 RETURN
6321 IF A$ ="1" GOTO 6366
6324 GOSUB 13000
6327 PRINT "--------------------  OR OPTION  --------------------------"
6333 PRINT "**************  WHAT FIELD DO YOU WANT ?  ******************"
6336 PRINT "FIELD NUMBER: ";Q;"FIELD NAME: ";FLDN$(A,Q)
6339 PRINT "********************  ORed WITH  ***************************"
6345 FOR N = (Q+1) TO NREC(A)
6348 PRINT "FIELD NUMBER: ";N;"FIELD NAME: ";FLDN$(A,N)
6351 NEXT N
6357 PRINT "***********  ENTER THE NUMBER THEN PRESS RETURN  ***********"
6360 GOSUB 14000
6361 IF DT# <(Q+1) OR DT# > NREC(A) GOTO 6360
6363 ORN(Q) = DT#
6366 RETURN
6369 GOSUB 6603
6372 F4 = 23
6375 GOSUB 13000
6378 PRINT "********  WHAT RECORD DO YOU WANT TO START AT  *********"
6381 PRINT ""
6384 PRINT "********  ENTER THE NUMBER THEN PRESS RETURN  *********"
6387 GOSUB 14100
6388 IF DT# <1 OR DT# > 10000  GOTO 6387
6390 RN = DT#
6393 RETURN
6396 REM GET RECORD
6399 IF INKEY$ <> "" THEN GOSUB 6576
6402 IF RN > MRN THEN GOSUB 26500
6403 IF EFLG = 1 GOTO 6810
6405 GET #1,RN
6417 FOR J = 1 TO NREC(A)
6420 ORFLG(J) = 0
6423 NEXT J
6426 RETURN
6429 Q = Q + 1
6432 REM
6435 ON FTY(A,Q) GOTO 6507,6441,6453,6465,6465
6438 REM ************** CONVERT STRINGS TO DECIMALS ****************
6441 I%=CVI(X$(Q))
6444 I# = I%
6447 S#(Q) = I#
6450 GOTO 6471
6453 I!=CVS(X$(Q))
6456 I# = I!
6459 S#(Q) = I#
6462 GOTO 6471
6465 I#=CVD(X$(Q))
6468 S#(Q) = I#
6471 IF ORFLG(Q) = 1 GOTO 6546
6474 REM ************** CHECK NUMBERS FOR RELATIONS ***************
6477 ON EGL(Q) GOTO 6546,6480,6492,6498,6502
6480 FOR K = 1 TO KT(Q)
6483 IF I#=I#(Q,K) GOTO 6546
6486 NEXT K
6489 GOTO 6561
6492 IF I#>I#(Q,1) GOTO 6546
6495 GOTO 6561
6498 IF I# < I#(Q,1) GOTO 6546
6501 GOTO 6561
6502 IF I# > I#(Q,1) AND I# < I#(Q,2) GOTO 6546
6503 GOTO 6561
6504 REM **************CHECK STRINGS FOR RELATIONS **************
6507 ON EGL(Q) GOTO 6546,6510,6534,6540,6544
6510 FOR K = 1 TO KT(Q)
6513 Y$ = I$(Q,K)
6516 Y = LEN(Y$)
6519 X$ = X$(Q)
6522 X$ = LEFT$(X$,Y)
6525 IF X$=I$(Q,K) GOTO 6546
6528 NEXT K
6531 GOTO 6561
6534 IF X$(Q) > I$(Q,1) GOTO 6546
6537 GOTO 6561
6540 IF X$(Q) < I$(Q,1) GOTO 6546
6543 GOTO 6561
6544 IF X$(Q) > I$(Q,1) AND X$(Q) < I$(Q,2) GOTO 6546
6545 GOTO 6561
6546 P = ORN(Q)
6549 IF P = 0 GOTO 6555
6552 ORFLG(P) = 1
6555 TEST = 1
6558 RETURN
6561 TEST = 0
6567 IF ORN(Q) <> O THEN TEST = 1 ELSE TEST = 2
6573 RETURN
6576 REM ******** PAUSE SUBROUTINE ********
6579 PRINT "******************  PAUSE SUBROUTINE  **********************"
6582 PRINT " 1 - CONTINUE SCANNING"
6585 PRINT " 0 - STOP SCANNING "
6588 PRINT "***********  ENTER THE NUMBER THEN PRESS RETURN  ***********"
6591 GOSUB 14000
6593 IF DT# <0 OR DT# >1  GOTO 6588
6597 IF DT# = 0 THEN GOTO 6810
6600 RETURN
6603 REM *******  ADD OPTIONS FOR THE SELECTIVE SCAN ROUTINE  *******
6606 GOSUB 13000
6609 PRINT "********************  ADD OPTIONS  ***********************"
6612 PRINT ""
6615 PRINT "   1 - DO NOT ADD"
6618 PRINT "   2 - ADD FIELDS"
6621 PRINT "   3 - ADD FIELDS WITH SUBTOTALS BY ANOTHER FIELD "
6624 PRINT "   4 - BOTH 2 & 3"
6627 PRINT ""
6630 PRINT "**********  ENTER THE NUMBER THEN PRESS RETURN  ***********"
6633 GOSUB 14000
6634 IF DT# <1 OR DT# >4  GOTO 6633
6636 ADOPT = DT#
6637 IF ADOPT > 1 THEN GOSUB 10600
6639 ON ADOPT GOTO 6756,6642,6696,6642
6642 GOSUB 13000
6645 PRINT "**********  HOW MANY FIELDS DO YOU WANT TO ADD  **********"
6648 PRINT ""
6651 FOR T = 1 TO NREC(A)
6654 PRINT T;" - ";FLDN$(A,T)
6657 NEXT T
6660 PRINT "**********  HOW MANY FIELDS DO YOU WANT TO ADD  **********"
6663 GOSUB 14000
6664 IF DT# <1 OR DT#> NREC(A) GOTO 6663
6666 KTSUM = DT#
6669 FOR T = 1 TO KTSUM
6672 PRINT "*****  WHICH FIELD IS THE ";T;"th YOU WAMT TO ADD  *****"
6675 GOSUB 14000
6676 IF DT# <1 OR DT#> NREC(A) GOTO 6675
6677 IF FTY(A,DT#) = 1 GOTO 6675
6678 FTA(T) = DT#
6681 NEXT T
6684 FOR T = 1 TO KTSUM
6687 SUM#(T) = 0
6690 NEXT T
6693 IF ADOPT = 2 GOTO 6756
6696 GOSUB 13000
6699 PRINT "***  HOW MANY FIELDS DO YOU WANT TO SUBTOTAL BY ANOTHER FIELD  ***"
6702 PRINT ""
6705 FOR T = 1 TO NREC(A)
6708 PRINT T;" - ";FLDN$(A,T)
6711 NEXT T
6714 PRINT ""
6717 PRINT "*************  ENTER THE NUMBER THEN PRESS RETURN  ***************"
6720 GOSUB 14000
6721 IF DT#<1 OR DT#>NREC(A) GOTO 6720
6723 KTSAF = DT#
6724 FOR T = 1 TO KTSAF
6725 PRINT "****  WHICH FIELD IS THE ";T;" th FIELD YOU WANT TO SUBTOTAL  ****"
6726 GOSUB 14000
6727 IF DT#<1 OR DT#>NREC(A) GOTO 6726
6728 IF FTY(A,DT#) = 1 GOTO 6726
6731 ATF(T) = DT#
6732 PRINT "*********  WHICH FIELD DO YOU WANT SUBTOTALS GROUPED BY  *********"
6733 PRINT "                  Must be an interger field  "
6734 GOSUB 14000
6735 IF DT#<1 OR DT#>NREC(A) GOTO 6734
6736 IF FTY(A,DT#) <> 2 GOTO 6734
6737 BTF(T) = DT#
6738 IMAX(T) = 0
6739 NEXT T
6741 FOR T = 1 TO KTSAF
6744 FOR I = 1 TO 99
6747 SAF#(T,I) = 0
6750 NEXT I
6753 NEXT T
6756 RETURN
6759 REM ***** ADD SUBROUTINE *******
6765 IF ADOPT = 3 GOTO 6783
6768 FOR T = 1 TO KTSUM
6771 F = FTA(T)
6774 SUM#(T) = SUM#(T) + S#(F)
6777 NEXT T
6780 IF ADOPT = 2 THEN RETURN
6783 REM ******  ADD ACCORDING TO ANOTHER FIELD  *******
6786 FOR T = 1 TO KTSAF
6789 T1 = ATF(T)
6792 T2 = BTF(T)
6793 IF T2 <= 0 THEN T2 = 99
6794 IF T2 >100 THEN T2 = 99
6795 T3 = S#(T2)
6797 IF T3 > IMAX(T) THEN IMAX(T) = T3
6798 SAF#(T,T3) = SAF#(T,T3) + S#(T1)
6804 NEXT T
6807 RETURN
6810 REM *******  PRINT SUMS ***********
6813 EFLG = 0
6819 IF ADOPT = 1 GOTO 3010
6825 PRINT "***********  PRINT SUMS ***********"
6828 IF ADOPT = 3 GOTO 6858
6831 PRINT "********* FIELD SUMS ***********"
6834 FOR T = 1 TO KTSUM
6837 T2 = FTA(T)
6840 PRINT FLDN$(A,T2),SUM#(T)
6841 IF SPRT = 2 THEN LPRINT FLDN$(A,T2),SUM#(T)
6843 NEXT T
6846 PRINT ""
6849 PRINT "PRESS ANY KEY TO CONTINUE "
6852 IF INKEY$ = "" GOTO 6852
6855 IF ADOPT = 2 GOTO 3010
6858 PRINT "******  SUM ACCORDING TO ANOTHER FIELD ********"
6861 FOR T = 1 TO KTSAF
6864 T2 = ATF(T)
6867 T3 = BTF(T)
6870 PRINT "SUM OF THIS FIELD :";FLDN$(A,T2)
6871 IF SPRT = 2 THEN LPRINT "SUM OF THIS FIELD :";FLDN$(A,T2)
6873 PRINT "SUBTOTALS BY FIELD :";FLDN$(A,T3)
6874 IF SPRT = 2 THEN LPRINT "SUBTOTALS BY FIELD :";FLDN$(A,T3)
6876 FOR I = 1 TO IMAX(T)
6879 PRINT I;"-";SAF#(T,I)
6880 IF SPRT = 2 THEN LPRINT I;"-";SAF#(T,I)
6882 NEXT I
6885 PRINT "PRESS ANY KEY TO CONTINUE "
6888 IF INKEY$ = "" GOTO 6888
6891 NEXT T
6894 GOTO 3010
7800 MRN = LOF(1)/ L(A)
7805 REM MRN = INT(MRN)
7810 RETURN
7900 REM ***** LOF
7910 MRN2 = LOF(3)/82
7920 RETURN
7950 REM ******* LOF
7960 MRNS = LOF(B)/L(B)
7970 RETURN
10000 REM *************  READ SUBROUTINE  *************
10004 GOSUB 10900
10010 OPEN "I",#1,"FFILE"
10020 INPUT #1,MAXF
10030 FOR A = 1 TO MAXF
10040 INPUT #1,A,F$(A),NREC(A),L(A)
10050 FOR N = 1 TO NREC(A)
10060 INPUT #1,FLDN$(A,N),FTY(A,N),FL(A,N)
10070 IF FTY(A,N) = 2 THEN INPUT #1,KY(A,N),KEYLIST(A,N)
10080 NEXT N
10090 NEXT A
10100 CLOSE #1
10110 RETURN
10200 REM  *******  SELECTIVE SCAN CONTINUED  ********
10210 GOSUB 13000
10220 PRINT "****************  SELECTIVE SCAN PROGRAM  *****************"
10230 PRINT ""
10240 PRINT "********  WHAT DO YOU WANT DONE WITH THE RESULTS  *********"
10250 PRINT ""
10260 PRINT "           1 - SHOWN ON THE MONITOR (TV) ONLY "
10370 PRINT "           2 - PRINT ON PAPER AND SHOWN ON THE MONITOR "
10400 PRINT ""
10500 PRINT "***********  ENTER THE NUMBER THEN PRESS RETURN  ***********"
10510 GOSUB 14000
10512 IF DT# <1 OR DT# >2 GOTO 10510
10520 IF DT# = 2 THEN PRTOPT = 1 ELSE PRTOPT = 0
10530 RETURN
10600  REM  ********  SELECTIVE SCAN CONTINUED  *********
10610 GOSUB 13000
10620 PRINT "**************  DO YOU WANT THE SUMS  **************"
10630 PRINT ""
10640 PRINT "         1 - SHOWN ON THE MONITOR (TV) ONLY "
10650 PRINT "         2 - PRINT ON PAPER AND SHOW ON THE MONITOR "
10660 PRINT ""
10670 PRINT "*******  ENTER THE NUMBER THEN PRESS RETURN  ********"
10680 GOSUB 14000
10682 IF DT# <1 OR DT# >2  GOTO 10680
10690 SPRT = DT#
10695 RETURN
10700 REM ******  SELECTIVE SCAN INTRO
10705 GOSUB 13000
10710 PRINT "*************************   SELECTIVE SCAN ROUTINE   ************************"
10720 PRINT ""
10730 PRINT "   The selective scan routine will display each field in the file then ask"
10740 PRINT "you what conditons if any you want to place on the field.  You may place  "
10750 PRINT "a conditon on every field if you wish to do so.  "
10755 PRINT ""
10760 PRINT "   The computer will then display only the records that meet the conditions"
10770 PRINT "that you specified.  The computer will give you the option to add the records"
10780 PRINT "Only the records that meet the conditons you specified will be added."
10790 PRINT "If you want to add all the records do not put any condition on any of the "
10800 PRINT "fields.
10805 PRINT ""
10810 PRINT "  If you do specify a condition for a field the computer will ask you if you "
10815 PRINT "want to OR the conditon with a condition of another field.  If you chose the"
10820 PRINT "OR option only one of the conditions will need to be meet for the record to "
10825 PRINT "be acceptable.  You may OR two or more conditions together."
10830 PRINT "   If you use the OR option. Specify the or condition only once on the lowest"
10840 PRINT "number field that you are ORING together.  For example if you wantto OR the "
10850 PRINT "second and fourth field specify the OR conditions on the second field not"
10855 PRINT "on the fourth field.  See the manual for more information."
10865 PRINT ""
10870 PRINT "***********************  PRESS ANY KEY TO CONTINUE  ************************"
10880 IF INKEY$ = "" GOTO 10880
10890 RETURN
10900 REM  *************  PUT DISK IN DRIVE SUB
10905 IF HDISK = 2 THEN RETURN
10910 GOSUB 13000
10920 PRINT "    ********  PUT PROGRAM DATA DISK IN THE DEFAULT DISK DRIVE  *********"
10930 PRINT ""
10940 PRINT "                     THEN PRESS ANY KEY TO CONTINUE "
10950 PRINT ""
10960 PRINT "    If the program data disk is already in the default disk drive then"
10965 PRINT "                   just press any key to continue."
10970 PRINT ""
10990 IF INKEY$ = "" GOTO 10990
10995 RETURN
11000 REM  ********  LOAD KEYLIST  *********
11010 GOSUB 13000
11100 A = 10
11105 PRINT "FILE : KEYLIST "
11110 GOSUB 2300
11120 GOSUB 2500
11130 FOR T = 1 TO 10000
11140 IF T > MRN GOTO 11900
11150 GET #1,T
11160 T1 = CVI(X$(1))
11170 T2 = CVI(X$(2))
11180 L$(T1,T2) = X$(3)
11185 IF T2 > MAXK(T1) THEN MAXK(T1) = T2
11190 NEXT T
11900 KD = 5
11935 CLOSE #1
11940 RETURN
12000 REM ******  PRINT SUBROUTINE  *****
12010 PRINT "*************  FILE : ";F$(A);"- ";"RECORD NUMBER: ";RN;" *************"
12020 FOR Q = 1 TO NREC(A)
12025 IF Q MOD 20 = 0 THEN GOSUB 12170
12030 PRINT Q; TAB(5) FLDN$(A,Q);
12040 ON FTY(A,Q) GOTO 12050,12070,12100,12130,12142
12050 PRINT TAB(26) X$(Q)
12060 GOTO 12150
12070 I%=CVI(X$(Q))
12075 PRINT TAB(25) I%;
12080 IF KY(A,Q) <> 2 THEN PRINT ""
12082 IF KY(A,Q) <> 2 THEN GOTO 12150
12084 T1 = KEYLIST(A,Q)
12085 IF I% < 0 THEN I% = 0
12086 W$ = L$(T1,I%)
12090 PRINT TAB(30) "key: ";W$
12095 GOTO 12150
12100 I!=CVS(X$(Q))
12110 PRINT TAB(25) I!
12120 GOTO 12150
12130 I#=CVD(X$(Q))
12140 PRINT TAB(25)  I#
12141 GOTO 12150
12142 I#=CVD(X$(Q))
12144 PRINT TAB(26);
12146 PRINT USING "**$########.##";I#
12150 NEXT Q
12152 IF Q < 20 THEN RETURN
12153 PRINT""
12154 PRINT ""
12155 PRINT ""
12156 PRINT ""
12157 PRINT ""
12160 RETURN
12170 RETURN
12180 IF INKEY$ = "" GOTO 12180
12190 RETURN
12200 PRINT ""
12210 LPRINT ""
12220 PRINT "RECORD NUMBER: ";RN
12230 LPRINT "RECORD NUMBER: ";RN
12240 FOR Q = 1 TO NREC(A)
12250 PRINT  Q;TAB(5) FLDN$(A,Q);
12260 LPRINT Q;TAB(5) FLDN$(A,Q);
12270 ON FTY(A,Q) GOTO 12280,12310,12350,12390,12425
12280 PRINT TAB(26) X$(Q)
12290 LPRINT TAB(26) X$(Q)
12300 GOTO 12480
12310 I%=CVI(X$(Q))
12312 PRINT TAB(25) I%;
12314 LPRINT TAB(25) I%;
12316 IF KY(A,Q) <> 2 THEN PRINT ""
12318 IF KY(A,Q) <> 2 THEN LPRINT ""
12320 IF KY(A,Q) <> 2 THEN GOTO 12480
12322 T1 = KEYLIST(A,Q)
12324 W$ = L$(T1,I%)
12326 PRINT TAB(30) "key: ";W$
12328 LPRINT TAB(30) "key: ";W$
12330 GOTO 12480
12340 GOTO 12480
12350 I!=CVS(X$(Q))
12360 PRINT TAB(25) I!
12370 LPRINT TAB(25) I!
12380 GOTO 12480
12390 I#=CVD(X$(Q))
12400 PRINT TAB(25)  I#
12410 LPRINT TAB(25)  I#
12420 GOTO 12480
12425 I#=CVD(X$(Q))
12430 PRINT TAB(26);
12440 PRINT USING "**$########.##";I#
12450 LPRINT TAB(26);
12460 LPRINT USING "**$########.##";I#
12480 NEXT Q
12490 RETURN
12500 PRINT ""
12510 LPRINT ""
12520 PRINT "RECORD # ";RN;" ";
12530 LPRINT "RECORD # ";RN;" ";
12540 FOR Q = 1 TO NREC(A)
12545 IF LEND(Q)= 5 THEN PRINT ""
12547 IF LEND(Q)= 5 THEN LPRINT ""
12548 T2 = CL(Q) + 6
12550 PRINT TAB(CL(Q))"<";Q;">";
12560 LPRINT TAB(CL(Q))"<";Q;">";
12570 ON FTY(A,Q) GOTO 12580,12610,12730,12770,12810
12580 PRINT TAB(T2) X$(Q);
12590 LPRINT TAB(T2) X$(Q);
12600 GOTO 12860
12610 I%=CVI(X$(Q))
12620 PRINT TAB(T2)I%;
12630 LPRINT TAB(T2)I%;
12660 IF KY(A,Q) <> 2 THEN GOTO 12860
12670 T1 = KEYLIST(A,Q)
12680 W$ = L$(T1,I%)
12685 T1 = CL(Q) + 11
12690 PRINT TAB(T1)"key: ";W$;
12700 LPRINT TAB(T1)"key: ";W$;
12720 GOTO 12860
12730 I!=CVS(X$(Q))
12740 PRINT TAB(T2)I!;
12750 LPRINT TAB(T2)I!;
12760 GOTO 12860
12770 I#=CVD(X$(Q))
12780 PRINT TAB(T2)I#;
12790 LPRINT TAB(T2)I#;
12800 GOTO 12860
12810 I#=CVD(X$(Q))
12820 PRINT TAB(T2) "";
12830 PRINT USING "**$########,.##";I#;
12840 LPRINT TAB(T2) "";
12850 LPRINT USING "**$########,.##";I#;
12860 NEXT Q
12870 RETURN
12880 PRINT " HOW MANY COLUMNS ARE THERE ON YOUR PRINTER "
12890 GOSUB 14100
12892 COLM = DT#
12895 RETURN
12900 REM ******* TAB CONTROL *******
12901 C = 15
12902 FOR T = 1 TO NREC(A)
12903 LEND(T) = 0
12905 CL(T)= C
12906 GOSUB 12910:PRINT T;CL(T); " RETURNED FROM 12910 "
12907 IF C > COLM THEN GOSUB 12970
12908 PRINT T;CL(T): NEXT T
12909 RETURN
12910 ON FTY(A,T) GOTO 12920,12930,12940,12950,12950
12920 C = C + FL(A,T) + 5
12925 RETURN
12930 C = C + 11
12933 IF KY(A,T) = 2 THEN C = C + 30
12935 RETURN
12940 C = C + 13
12945 RETURN
12950 C = C + 18
12952 RETURN
12970 CL(T)= 1
12972 C =1
12974 LEND(T) = 5
12975 GOSUB 12910
12980 RETURN
13000 REM *********  CLEAR SCREEN
13010 CLS
13020 RETURN
13100 REM *********  LOCATE
13110 LOCATE LI,1
13120 RETURN
13200 FOR T% = 1 TO 80
13210 PRINT CHR$(8);
13220 NEXT T%
13222 FOR T% = 1 TO 24
13223 PRINT CHR$(11);
13224 NEXT T%
13225 LI = LI - 1
13230 FOR T% = 1 TO LI
13240 PRINT CHR$(0)
13250 NEXT T%
13590 RETURN
13600 REM ****** CHECK FOR ASC0
13610 S4$ = INKEY$
13620 C2 =  ASC(S4$)
13630 IF C2 = 83 THEN C = 1
13640 IF C2 = 82 THEN C = 6
13650 IF C2 = 75 THEN C = 19
13660 IF C2 = 77 THEN C = 4
13670 RETURN
14000 REM *******  INTEGER LESS THEN 100 CHECK  ********
14010 MAX = 2
14020 ACT$ = "1234567890=<>^"
14023 IF NE = 0 THEN ACT$ = "1234567890"
14025 PRINT ">__<";
14030 GOTO 14500
14100 REM *******  INTEGER *******
14110 MAX = 8
14120 ACT$ = "1234567890-+,=<>^"
14123 IF NE = 0 THEN ACT$ = "1234567890-+,"
14125 PRINT ">________<";
14130 GOTO 14500
14200 REM *******  SINGLE PRECISION  *******
14210 MAX = 10
14220 ACT$ = "1234567890-+,.%$=<>^"
14223 IF NE = 0 THEN ACT$ = "1234567890+-,.%$"
14225 PRINT ">__________<";
14230 GOTO 14500
14300 REM *******  DOUBLE PRECISION  *******
14310 MAX = 20
14320 ACT$ = "1234567890-+,.%$=<>^"
14323 IF NE = 0 THEN ACT$ = "1234567890+-,.%$"
14325 PRINT ">____________________<";
14330 GOTO 14500
14500 REM ********** NUMBER CHECK **********
14505 A$ = ""
14510 K$(20) = " "
14515 KTMAX = 0
14520 FOR T9 = 1 TO MAX
14525 K$(T9) = " "
14530 NEXT T9
14535 DIG$ = "1234567890."
14540 DOTFLG = 0
14541 T2 = MAX + 1
14542 FOR T6 = 1 TO T2
14544 PRINT CHR$(CH);
14546 NEXT T6
14550 IF INKEY$ = "" GOTO 14560 ELSE GOTO 14550
14560 KT = 0
14565 REM ***********  CHECK ALFANUMERIC INPUT FOR LENGTH  ***********
14570 KT = KT + 1
14575 REM
14580 W$ = INKEY$
14585 IF W$ = "" GOTO 14580
14590 C = ASC(W$)
14593 IF C = 0 THEN GOSUB 13600
14595 IF C = 13 GOTO 14660
14600 IF C = 17 OR C = 8 GOTO 14860
14605 IF C = 19 GOTO 14690
14610 IF C = 4 GOTO 14710
14615 IF C = 6 GOTO 14730
14620 IF C = 1 GOTO 14790
14625 IF KT > MAX GOTO 14575
14630 IF INSTR(ACT$,W$) = 0 GOTO 14890
14635 K$(KT) = W$
14645 PRINT K$(KT);
14650 IF KT > KTMAX THEN KTMAX = KT
14655 GOTO 14570
14660 REM **********  RETURN  **********
14670 FOR T9 = 1 TO KTMAX
14675 A$ = A$ + K$(T9)
14676 IF K$(T9) = "^" GOTO 15830
14677 IF K$(T9) = ">" GOTO 15950
14678 IF K$(T9) = "=" GOTO 15800
14679 IF K$(T9) = "<" GOTO 15900
14680 NEXT T9
14681 IF KTMAX = 0 THEN PRINT "1"
14682 IF KTMAX = 0 THEN DT# = 1
14683 IF KTMAX = 0 THEN RETURN
14684 PRINT ""
14685 GOTO 14905
14690 REM ********* MOVE CURSE BACK ********
14695 IF KT = 1 GOTO 14575
14700 KT = KT - 1
14703 PRINT CHR$(CH);
14705 GOTO 14575
14710 REM ********* MOVE CURSER FORWARD *********
14715 IF KT >= MAX GOTO 14575
14716 IF KT > (KTMAX + 1) GOTO 14575
14718 PRINT K$(KT);
14720 KT = KT + 1
14725 GOTO 14575
14730 REM ********** INSERT ***********
14733 IF KT > KTMAX GOTO 14575
14735 X9 = MAX
14740 WHILE X9 > KT
14745 X9 = X9 - 1
14750 K$(X9 + 1) = K$(X9)
14755 WEND
14760 K$(KT) = " "
14767 KTMAX = KTMAX + 1
14769 IF KTMAX > MAX THEN KTMAX = MAX
14770 FOR T9 = KT TO KTMAX
14775 PRINT K$(T9);
14780 NEXT T9
14781 T6 = (KTMAX - KT) + 1
14782 FOR T7 = 1 TO T6
14783 PRINT CHR$(CH);
14784 NEXT T7
14785 GOTO 14575
14790 REM ********** DELETE ***********
14793 IF KT > KTMAX GOTO 14575
14794 IF KTMAX = 1 GOTO 14575
14795 K$(MAX + 1) = ""
14800 X9 = KT
14805 WHILE X9 <= MAX
14810 K$(X9) = K$(X9 + 1)
14815 X9 = X9 + 1
14820 WEND
14830 KTMAX = KTMAX - 1
14835 FOR T9 = KT TO KTMAX
14840 PRINT K$(T9);
14845 NEXT T9
14850 PRINT "_";
14851 T7 = (KTMAX - KT) + 2
14852 FOR T8 = 1 TO T7
14853 PRINT CHR$(CH);
14854 NEXT T8
14855 GOTO 14575
14860 REM ********* BACKSPACE ********
14865 IF KT = 1 GOTO 14575
14870 KT = KT - 1
14875 PRINT CHR$(CH);
14877 K$(KT) = " "
14880 PRINT "_";
14883 PRINT CHR$(CH);
14885 GOTO 14575
14890 REM *******  INPUT NOT ACCEPTABLE  ********
14895 PRINT CHR$(7);
14900 GOTO 14580
14905 REM ********* CLEAR STRINGS ********
14910 MAX = LEN(A$)
14915 D2$ = ""
14920 D1$ = ""
14925 DFLG = 0
14930 FOR Q93 = 1 TO MAX
14935 R$ = MID$(A$,Q93,1)
14940 IF INSTR(DIG$,R$) = 0 GOTO 14975
14945 IF R$ = "." OR DFLG = 1 GOTO 14965
14950 IF DFLG = 1 GOTO 14965
14955 D2$ = D2$ + R$
14960 GOTO 14975
14965 D1$ = D1$ + R$
14970 DFLG = 1
14975 NEXT Q93
14980 DA# = VAL(D2$)
14985 D1# = VAL(D1$)
14990 DT# = DA# + D1#
14995 IF K$(1) = "-" THEN DT# =  -DT#
14997 RETURN
15000 REM **********  ALPHANUMERIC CHECK  **************
15010 MAX = FL(A,Q)
15020 GOTO 15040
15030 REM ********  MAX SET IN PROGRAM  ********
15040 A$ = ""
15050 PRINT ">";
15060 FOR N9 = 1 TO MAX
15065 K$(N9) = ""
15070 PRINT "_";
15080 NEXT N9
15090 PRINT "<";
15100 T2 = MAX + 1
15110 FOR T4 = 1 TO T2
15120 PRINT CHR$(CH);
15125 NEXT T4
15130 KT = 0
15135 KTMAX = 1
15140 REM ***********  CHECK ALFANUMERIC INPUT FOR LENGTH  ***********
15150 KT = KT + 1
15160 PRINT TAB(KT+1)"";
15170 K$ = INKEY$
15180 IF K$ = "" GOTO 15170
15190 C = ASC(K$)
15195 IF C = 0 THEN GOSUB 13600
15200 IF C = 13 GOTO 15310
15210 IF C = 17 OR C = 8 GOTO 15710
15220 IF C = 19 GOTO 15370
15230 IF C = 4  GOTO 15410
15240 IF C = 6 GOTO 15450
15250 IF C = 1 GOTO 15570
15260 IF KT > MAX GOTO 15160
15270 K$(KT) = K$
15290 PRINT K$(KT);
15295 IF KT > KTMAX THEN KTMAX = KT
15300 GOTO 15150
15310 REM **********  RETURN  **********
15320 FOR T9 = 1 TO MAX
15330 A$ = A$ + K$(T9)
15332 IF K$(T9) = "^" GOTO 15830
15333 IF K$(T9) = ">" GOTO 15950
15335 IF K$(T9) = "=" GOTO 15850
15338 IF K$(T9) = "<" GOTO 15900
15340 NEXT T9
15350 PRINT ""
15360 RETURN
15370 REM ********* MOVE CURSE BACK ********
15380 IF KT = 1 GOTO 15160
15385 KT = KT - 1
15390 PRINT CHR$(CH);
15400 GOTO 15160
15410 REM ********* MOVE CURSER FORWARD *********
15420 IF KT >= MAX GOTO 15160
15425 IF KT >  KTMAX  GOTO 15160
15427 PRINT K$(KT);
15430 KT = KT + 1
15440 GOTO 15160
15450 REM ********** INSERT ***********
15460 X9 = MAX
15470 WHILE X9 > KT
15480 X9 = X9 - 1
15490 K$(X9 + 1) = K$(X9)
15500 WEND
15510 K$(KT) = " "
15520 KTMAX = KTMAX + 1
15525 IF KTMAX > MAX THEN KTMAX = MAX
15530 FOR T9 = KT TO KTMAX
15540 PRINT K$(T9);
15550 NEXT T9
15552 T6 = (KTMAX - KT) +1
15554 FOR T7 = 1 TO T6
15556 PRINT CHR$(CH);
15558 NEXT T7
15560 GOTO 15160
15570 REM ********** DELETE ***********
15575 IF KT > KTMAX GOTO 15170
15578 IF KTMAX = 1 GOTO 15160
15580 K$(MAX + 1) = ""
15590 X9 = KT
15600 WHILE X9 <= KTMAX
15610 K$(X9) = K$(X9 + 1)
15620 X9 = X9 + 1
15630 WEND
15650 KTMAX = KTMAX - 1
15660 FOR T9 = KT TO KTMAX
15670 PRINT K$(T9);
15680 NEXT T9
15690 PRINT "_";
15692 T7 = (KTMAX - KT) + 2
15694 FOR T6 = 1 TO T7
15696 PRINT CHR$(CH);
15698 NEXT T6
15700 GOTO 15160
15710 REM ********* BACKSPACE ********
15720 IF KT = 1 GOTO 15160
15725 K$(KT) = " "
15730 KT = KT - 1
15735 K$(KT) = " "
15740 PRINT CHR$(CH);
15750 PRINT "_";
15755 PRINT CHR$(CH);
15760 GOTO 15160
15800 REM "*********  SAME ENTRY AS LAST RECORD  ************"
15810 DT# = X(N)
15820 RETURN
15830 REM ********  SAME ENTRY AS LAST RECORD   OVER ONE COLUMN  *****
15835 DT# = X(N + 1)
15840 RETURN
15850 REM "*********  SAME ENTRY AS LAST RECORD ALFANUMERIC  **********"
15860 A$ = CK$(N)
15870 RETURN
15900 REM  ******  RESTART DATA ENTRY  **********
15910 REFLG = 1
15915 IF NE = 0 GOTO 15340
15920 RETURN
15950 REM  *********  ABORT NEW DATA ENTRY  **********
15960 IF NE = 0 GOTO 15340
15970 ABORTFLG = 1
15980 RETURN
16000 GOSUB 13000
16010 PRINT "***********  MAKE SURE YOUR PRINTER IS ON  **************"
16020 PRINT ""
16030 PRINT "********************  WITH PAPER  ***********************"
16040 PRINT ""
16050 PRINT "**********  PRESS ANY KEY TO START PRINTING  ************"
16055 PRINT ""
16057 PRINT "     *******  PRESS THE LETTER A TO ABORT  *******"
16070 T$ = INKEY$
16073 IF T$ = "" GOTO 16070
16075 PRINT T$
16085 IF T$ = "A" THEN GOTO 3010
16090 RETURN
16200 REM *********  PRINT OUT FIELDS
16205 T2 = 1
16210 FOR T = 1 TO NREC(A)
16220 PRINT TAB(T2) T;"-";FLDN$(A,T);
16230 IF T MOD 3 = 0 THEN PRINT ""
16235 IF T MOD 3 = 0 THEN T2 = -25
16237 T2 = T2 + 26
16340 NEXT T
16350 RETURN
26000 REM ******* ON ERROR ROUTINE ************
26100 EFLG = 1
26200 PRINT "**********  END OF FILE  ***********"
26202 PRINT "**** PRESS ANY KEY TO CONTINUE ****"
26204 IF INKEY$ = "" GOTO 26204
26210 GOTO  3010
26500 REM *********  ON ERROR SUBROUTINE ***********
26600 PRINT "**********  END OF FILE  ***********"
26610 PRINT "**** PRESS ANY KEY TO CONTINUE ****"
26620 IF INKEY$ = "" GOTO 26620
26635 EFLG = 1
26640 RETURN
26800 REM **********  ON ERROR GOTO  **************
26900 PRINT "************  RECORD NOT FOUND  *************"
50000 REM **********  INTRO
50010 GOSUB 13000
50100 PRINT "                S C A N    P R O G R A M    3.0   "
50105 PRINT ""
50110 PRINT "      Copyright 1984 by Potomac Pacific Engineering Inc."
50120 PRINT ""
50130 PRINT "This program is licensed FREE to all users with some restrictions"
50165 PRINT "        See the manual for more information on the license."
50167 PRINT ""
50950 PRINT "*****************  PRESS ANY KEY TO CONTINUE  *******************";
50960 IF INKEY$ = "" GOTO 50960
50970 RETURN
51000 REM *******  DONE
51100 CLOSE
51105 GOSUB 13000
51110 PRINT " -BYE, Have a nice day
51120 END
 50960
50970 RETURN
51000 REM *******  DONE
51100 CLOSE
51105 GOSUB 13000
51110 PRINT " -BYE, Have a nice day